home *** CD-ROM | disk | FTP | other *** search
/ The 640 MEG Shareware Studio 2 / The 640 Meg Shareware Studio CD-ROM Volume II (Data Express)(1993).ISO / prog / atease2.zip / BIO.BAS next >
BASIC Source File  |  1988-09-07  |  11KB  |  437 lines
  1. DEFINT A-Z
  2.  
  3. DIM sayv(52)                        'save area for background behind bar
  4. backup# = 16#                       '# of days to backup for start of display
  5. intday# = .196875#                  'relative x adjustment for intellectual
  6. emoday# = .23203125#                'relative x adjustment for emotional
  7. phyday# = .282472826086956#         'relative x adjustment for physical
  8. absday# = 6.53125#                  'relative x adjustment for actual day
  9.  
  10. DIM MonthLength(12)
  11. MonthLength(1) = 31
  12. MonthLength(2) = 29
  13. MonthLength(3) = 31
  14. MonthLength(4) = 30
  15. MonthLength(5) = 31
  16. MonthLength(6) = 30
  17. MonthLength(7) = 31
  18. MonthLength(8) = 31
  19. MonthLength(9) = 30
  20. MonthLength(10) = 31
  21. MonthLength(11) = 30
  22. MonthLength(12) = 31
  23.  
  24. DIM MonthName$(12)
  25. MonthName$(1) = "JAN"
  26. MonthName$(2) = "FEB"
  27. MonthName$(3) = "MAR"
  28. MonthName$(4) = "APR"
  29. MonthName$(5) = "MAY"
  30. MonthName$(6) = "JUN"
  31. MonthName$(7) = "JUL"
  32. MonthName$(8) = "AUG"
  33. MonthName$(9) = "SEP"
  34. MonthName$(10) = "OCT"
  35. MonthName$(11) = "NOV"
  36. MonthName$(12) = "DEC"
  37.  
  38. DIM DaysPrior(12)
  39. DaysPrior(1) = 0
  40. DaysPrior(2) = 31
  41. DaysPrior(3) = 59
  42. DaysPrior(4) = 90
  43. DaysPrior(5) = 120
  44. DaysPrior(6) = 151
  45. DaysPrior(7) = 181
  46. DaysPrior(8) = 212
  47. DaysPrior(9) = 243
  48. DaysPrior(10) = 273
  49. DaysPrior(11) = 304
  50. DaysPrior(12) = 334
  51.  
  52. ErrMsg$(1) = "Date must be 11 characters: DD MMM YYYY."
  53. ErrMsg$(2) = "Not a valid month abbreviation."
  54. ErrMsg$(3) = "Day out of range for this month."
  55. ErrMsg$(4) = "Year must be a number."
  56. ErrMsg$(5) = "No February 29 in this year!"
  57.  
  58. SCREEN 1, 0
  59. COLOR 0, 1
  60.  
  61. datecalc:
  62. work$ = ""
  63. DO WHILE Escape <> 1
  64.     VIEW (0, 0)-(319, 59): CLS          'this stuff clears the screen
  65.     VIEW (0, 61)-(319, 199): CLS
  66.     VIEW
  67.     LINE (0, 60)-(319, 60), 1
  68.     VIEW
  69.     LOCATE 1, 10: PRINT "The Biorhythm Program";
  70.     LOCATE 25, 11: PRINT "(Press Esc to quit.)";
  71.     LOCATE 11, 4: PRINT "Please enter dates as follows:";
  72.     LOCATE 13, 4: PRINT "         DD MMM YYYY";
  73.     LOCATE 15, 4: PRINT "Example: 01 FEB 1953";
  74.     LOCATE 17, 4: PRINT "Note: All days must be two digits.";
  75.     LOCATE 20, 1: PRINT "Enter your birth date: ";
  76.     GOSUB GetDate
  77.     IF Escape = 1 THEN exit do      'NOTE: MUST BE EXIT LOOP FOR TURBO BASIC
  78.     birth$ = work$
  79.     LOCATE 21, 1: PRINT "Enter the biorhythm date: ";
  80.     GOSUB GetDate
  81.     IF Escape = 1 THEN exit do      'NOTE: MUST BE EXIT LOOP FOR TURBO BASIC
  82.     current$ = work$
  83.     work$ = birth$
  84.     GOSUB ConvertDate
  85.     birth# = work#
  86.     work$ = current$
  87.     GOSUB ConvertDate
  88.     current# = work#
  89.     IF current# < birth# THEN
  90.         a$ = "No pre-birth biorhythms available."
  91.         ex = (40 - LEN(a$)) / 2
  92.         if ex<1 then ex=1
  93.         LOCATE 22, ex: PRINT a$;
  94.         a$ = "Press any key to try again."
  95.         ex = (41 - LEN(a$)) / 2
  96.         if ex<1 then ex=1
  97.         LOCATE 23, ex: PRINT a$;
  98.         BEEP
  99.         a$ = ""
  100.         WHILE a$ = "": a$ = INKEY$: WEND
  101.         VIEW (0, 168)-(319, 191): CLS : VIEW
  102.     ELSE
  103.         diff# = current# - birth#               'here's the number of days
  104.         phy# = diff# MOD 23
  105.         emo# = diff# MOD 28
  106.         intl# = diff# MOD 33
  107.         VIEW (0, 61)-(319, 191): CLS : VIEW
  108.         GOSUB Biograph
  109.     END IF
  110. LOOP
  111.  
  112. SCREEN 0, 0, 0, 0: CLS
  113. END
  114.  
  115.  
  116. Biograph:
  117.  
  118. intl# = (intl# - backup#) * intday#
  119. emo# = (emo# - backup#) * emoday#
  120. phy# = (phy# - backup#) * phyday#
  121.  
  122. LINE (0, 60)-(319, 60), 1
  123. FOR x# = 0 TO 6.3 STEP .01                      'intellectual
  124.         PSET (50 + 33 * x#, 60 - 50 * SIN(x# + intl#)), 3
  125. NEXT
  126. FOR x# = 0 TO 7.425 STEP .01                    'emotional
  127.         PSET (50 + 28 * x#, 60 - 50 * SIN(x# + emo#)), 2
  128. NEXT
  129. FOR x# = 0 TO 9.0391 STEP .01                   'physical
  130.         PSET (50 + 23 * x#, 60 - 50 * SIN(x# + phy#)), 1
  131. NEXT
  132.  
  133. x# = backup# * absday#
  134. GET (50 + x#, 10)-(50 + x#, 110), sayv
  135. LINE (50 + x#, 10)-(50 + x#, 110)
  136. LOCATE 21, 13: PRINT "Physical: "
  137. LOCATE 22, 13: PRINT "Emotional: "
  138. LOCATE 23, 13: PRINT "Intellectual: "
  139.  
  140. a$ = ""
  141. DO WHILE a$ <> CHR$(27)
  142.         work$ = MonthName$(month) + STR$(day) + "," + STR$(year)
  143.         LOCATE 16, 1
  144.         PRINT "The vertical line marks your biorhythms";
  145.         LOCATE 17, 1
  146.         PRINT "for " + work$ + ". Use the arrow keys to ";
  147.         LOCATE 18, 1
  148.         PRINT "move the pointer to another day. Your";
  149.         LOCATE 19, 1
  150.         PRINT "place in the cycles is shown below.";
  151.  
  152. '   in your copy of the biorhythm program, these lines print
  153. '   in colors to match the corresponding curve. That printing
  154. '   is done using a proprietary assembler routine which we
  155. '   cannot include in At Ease. Therefore, you will see all
  156. '   text printed in white if you compile and run this source
  157. '   code. Sorry about that!
  158.  
  159.         ex = 28
  160.         IF 50 * SIN(x# / 23 + phy#) < -3 THEN
  161.           a$ = "-        "
  162.         ELSEIF 50 * SIN(x# / 23 + phy#) > 3 THEN
  163.           a$ = "+        "
  164.         ELSE
  165.           a$ = "Critical!"
  166.         END IF
  167.         LOCATE 21, ex: PRINT a$;
  168.         IF 50 * SIN(x# / 28 + emo#) < -3 THEN
  169.           a$ = "-        "
  170.         ELSEIF 50 * SIN(x# / 28 + emo#) > 3 THEN
  171.           a$ = "+        "
  172.         ELSE
  173.           a$ = "Critical!"
  174.         END IF
  175.         LOCATE 22, ex: PRINT a$;
  176.         a$ = "Intellectual: "
  177.         IF 50 * SIN(x# / 33 + intl#) < -3 THEN
  178.           a$ = "-        "
  179.         ELSEIF 50 * SIN(x# / 33 + intl#) > 3 THEN
  180.           a$ = "+        "
  181.         ELSE
  182.           a$ = "Critical!"
  183.         END IF
  184.         LOCATE 23, ex: PRINT a$;
  185.         a$ = ""
  186.         WHILE a$ = "": a$ = INKEY$: WEND
  187.         SELECT CASE a$
  188.  
  189.         CASE CHR$(0) + CHR$(75)                   'left arrow
  190.           IF x# > 2 THEN
  191.             PUT (50 + x#, 10), sayv, PSET
  192.             x# = x# - absday#
  193.             x = x#
  194.             IF x# < 2 THEN x# = 0
  195.             day = day - 1
  196.             IF day < 1 THEN
  197.               month = month - 1
  198.               IF month < 1 THEN
  199.                 month = 12
  200.                 year = year - 1
  201.               END IF
  202.               day = MonthLength(month)
  203.             END IF
  204.             GET (50 + x#, 10)-(50 + x#, 110), sayv
  205.             LINE (50 + x#, 10)-(50 + x#, 110)
  206.           END IF
  207.  
  208.         CASE CHR$(0) + CHR$(77)                   'right arrow
  209.           IF x# < 208 THEN
  210.             PUT (50 + x#, 10), sayv, PSET
  211.             x# = x# + absday#
  212.             x = x#
  213.             IF x# > 208 THEN x# = 208
  214.             day = day + 1
  215.             leap = year MOD 4
  216.             IF month = 2 AND day > 28 AND leap <> 0 THEN day = 30
  217.             IF day > MonthLength(month) THEN
  218.               month = month + 1
  219.               IF month > 12 THEN
  220.                 month = 1
  221.                 year = year + 1
  222.               END IF
  223.               day = 1
  224.             END IF
  225.             GET (50 + x#, 10)-(50 + x#, 110), sayv
  226.             LINE (50 + x#, 10)-(50 + x#, 110)
  227.           END IF
  228.  
  229.         CASE ELSE
  230.           a = a
  231.         END SELECT
  232.  
  233. LOOP
  234. RETURN
  235.  
  236. GetDate:
  237. curline = CSRLIN
  238. curpos = POS(0)
  239. et = 1
  240. work$ = "..........."
  241. DO WHILE et <> 0 AND Escape <> 1
  242.    et = 0
  243.    Max = 11
  244.    default$ = work$
  245.    CALL inpsub(0, 0, Max, work$, default$)
  246.    IF Escape = 1 THEN goto EndInputLoop
  247.    VIEW (0, 183)-(319, 191): CLS : VIEW
  248.    IF LEN(work$) <> 11 THEN
  249.      et = 1
  250.      GOSUB ErrorRoutine
  251.      GOTO EndInputLoop
  252.    END IF
  253.    month$ = MID$(work$, 4, 3)
  254.    month = 0
  255.    FOR i = 1 TO 12
  256.        IF month$ = MonthName$(i) THEN month = i
  257.    NEXT
  258.    IF month = 0 THEN
  259.      et = 2
  260.      GOSUB ErrorRoutine
  261.      GOTO EndInputLoop
  262.    END IF
  263.    day$ = LEFT$(work$, 2)
  264.    day = VAL(day$)
  265.    IF day < 1 OR day > MonthLength(month) THEN
  266.      et = 3
  267.      GOSUB ErrorRoutine
  268.      GOTO EndInputLoop
  269.    END IF
  270.    year$ = MID$(work$, 8, 4)
  271.    year = VAL(year$)
  272.    IF year < 1 THEN
  273.      et = 4
  274.      GOSUB ErrorRoutine
  275.      GOTO EndInputLoop
  276.    END IF
  277.    leap = year MOD 4
  278.    IF leap <> 0 AND month = 2 AND day > 28 THEN
  279.      et = 5
  280.      GOSUB ErrorRoutine
  281.      GOTO EndInputLoop
  282.    END IF
  283. EndInputLoop:
  284. LOOP
  285. RETURN
  286.  
  287. ConvertDate:
  288. month$ = MID$(work$, 4, 3)
  289. FOR i = 1 TO 12
  290.    IF month$ = MonthName$(i) THEN month = i
  291. NEXT
  292. day$ = LEFT$(work$, 2)
  293. day = VAL(day$)
  294. year$ = MID$(work$, 8, 4)
  295. year = VAL(year$)
  296. t1# = year * 365!
  297. t2# = year \ 4
  298. t3# = DaysPrior(month)
  299. work# = t1# + t2# + t3# + day
  300. leap = year MOD 4
  301. IF leap = 0 AND month < 3 THEN work# = work# - 1!
  302. RETURN
  303.  
  304. ErrorRoutine:
  305. ex = (41 - LEN(ErrMsg$(et))) / 2
  306. if ex<1 then ex=1
  307. LOCATE 24, ex: PRINT ErrMsg$(et);
  308. BEEP
  309. LOCATE curline, curpos, 1
  310. RETURN
  311.  
  312. SUB inpsub (row, col, Max, x$, default$)
  313.  
  314. SHARED Escape
  315.  
  316. Escape = 0
  317. IF col = 0 THEN col = POS(0)
  318. IF row = 0 THEN row = CSRLIN
  319. HoldCol = col
  320. HoldRow = row
  321. LOCATE row, col
  322. PRINT default$;
  323. p = 1
  324.  
  325. GetKey:
  326. IF p > Max THEN
  327.   p = p - 1
  328.   col = col - 1
  329. END IF
  330. LOCATE HoldRow, col, 1       ' Re-position the cursor
  331.  
  332. VIEW (0, HoldRow * 8)-(319, HoldRow * 8 + 1): CLS : VIEW
  333. LINE ((col - 1) * 8, HoldRow * 8)-(col * 8 - 2, HoldRow * 8), 3
  334.  
  335. k$ = ""
  336. WHILE k$ <> "": k$ = INKEY$: WEND       'purge keyboard buffer
  337. k$ = ""
  338. WHILE k$ = "": k$ = INKEY$: WEND
  339.  
  340. SELECT CASE k$             ' Determine which key pressed & act accordingly
  341.  
  342.   CASE CHR$(13)                             'enter
  343.     EXIT SUB
  344.  
  345.   CASE CHR$(27)                             'Esc
  346.     Escape = 1
  347.     EXIT SUB
  348.  
  349.   CASE CHR$(0) + CHR$(83)                   'Del
  350.     x$ = LEFT$(x$, p - 1) + MID$(x$, p + 1)
  351.     GOSUB ReDisplay
  352.  
  353.   CASE CHR$(0) + CHR$(82)                   'Ins
  354.     InsMode = (InsMode = 0)
  355.  
  356.   CASE CHR$(0) + CHR$(71)                   'Home
  357.     p = 1
  358.     col = HoldCol
  359.  
  360.   CASE CHR$(0) + CHR$(79)                   'End
  361.     p = LEN(x$)
  362.     col = HoldCol + p - 1
  363.     IF p < Max THEN
  364.       p = p + 1
  365.       col = col + 1
  366.     END IF
  367.  
  368.   CASE CHR$(0) + CHR$(75)                   'Left arrow
  369.     IF p > 1 THEN
  370.       p = p - 1
  371.       col = col - 1
  372.     ELSE
  373.       BEEP
  374.     END IF
  375.  
  376.   CASE CHR$(0) + CHR$(77)                   'Right arrow
  377.     IF p < Max THEN
  378.       IF p > LEN(x$) + 1 THEN x$ = x$ + " "
  379.       p = p + 1
  380.       col = col + 1
  381.     ELSE
  382.       BEEP
  383.     END IF
  384.  
  385.   CASE CHR$(0) + CHR$(117)                  'Ctrl-End
  386.     col = HoldCol
  387.     p = 1
  388.     x$ = ""
  389.     GOSUB ReDisplay
  390.  
  391.   CASE CHR$(8)                              'Backspace
  392.     IF p > 1 THEN
  393.       x$ = LEFT$(x$, p - 2) + MID$(x$, p)
  394.       p = p - 1
  395.       col = col - 1
  396.       GOSUB ReDisplay
  397.     ELSE
  398.       BEEP
  399.     END IF
  400.  
  401.   CASE " " TO "~"                           'ASCII key
  402.     k$ = UCASE$(k$)
  403.     IF InsMode THEN
  404.       IF LEN(x$) < Max THEN
  405.         x$ = LEFT$(x$, p - 1) + k$ + MID$(x$, p)
  406.         p = p + 1
  407.         col = col + 1
  408.         GOSUB ReDisplay
  409.       ELSE
  410.         BEEP
  411.       END IF
  412.     ELSE
  413.       IF p < Max + 1 THEN
  414.         x$ = LEFT$(x$, p - 1) + k$ + MID$(x$, p + 1)
  415.         LOCATE HoldRow, col
  416.         PRINT k$;
  417.         col = col + 1
  418.         p = p + 1
  419.       ELSE
  420.         BEEP
  421.       END IF
  422.     END IF
  423.  
  424.   CASE ELSE
  425.     BEEP
  426.  
  427. END SELECT
  428. GOTO GetKey
  429.  
  430. ReDisplay:
  431.   LOCATE HoldRow, HoldCol
  432.   PRINT LEFT$(x$ + string$(Max,"."), Max);
  433.   RETURN
  434.  
  435. END SUB
  436.  
  437.